home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / modes / xpm-mode.el.z / xpm-mode.el
Encoding:
Text File  |  1998-05-21  |  14.4 KB  |  455 lines
  1. ;;; xpm-mode.el    --- minor mode for editing XPM files
  2.  
  3. ;; Copyright (C) 1995 Joe Rumsey <ogre@netcom.com>
  4. ;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
  5.  
  6. ;; Authors: Joe Rumsey <ogre@netcom.com>
  7. ;;        Rich Williams <rdw@hplb.hpl.hp.com>
  8. ;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu>
  9.  
  10. ;; Version:  1.5
  11. ;; Last Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995
  12. ;; Keywords: data tools
  13.  
  14. ;; This file is part of XEmacs.
  15.  
  16. ;; XEmacs is free software; you can redistribute it and/or modify it
  17. ;; under the terms of the GNU General Public License as published by
  18. ;; the Free Software Foundation; either version 2, or (at your option)
  19. ;; any later version.
  20.  
  21. ;; XEmacs is distributed in the hope that it will be useful, but
  22. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24. ;; General Public License for more details.
  25.  
  26. ;; You should have received a copy of the GNU General Public License
  27. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  28. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29. ;; Boston, MA 02111-1307, USA.
  30.  
  31. ;;; Synched up with: Not in FSF.
  32.  
  33. ;;
  34. ;; xpm mode:  Display xpm files in color
  35. ;;
  36. ;; thanks to Rich Williams for mods to do this without font-lock-mode,
  37. ;; resulting in much improved performance and a better display
  38. ;; (headers don't get colored strangely). Also for the palette toolbar.
  39. ;;
  40. ;; Non-standard minor mode in that it starts picture-mode automatically.
  41. ;;
  42. ;; To get this turned on automatically for .xpms, add an entry
  43. ;;       ("\\.xpm" . xpm-mode)
  44. ;; to your auto-mode-alist.  For example, my .emacs has this: (abbreviated)
  45. ;; (setq auto-mode-alist (mapcar 'purecopy
  46. ;;                               '(("\\.c$" . c-mode)
  47. ;;                                ("\\.h$" . c-mode)
  48. ;;                                ("\\.el$" . emacs-lisp-mode)
  49. ;;                  ("\\.emacs$" . emacs-lisp-mode)
  50. ;;                                ("\\.a$" . c-mode)
  51. ;;                  ("\\.xpm" . xpm-mode))))
  52. ;; (autoload 'xpm-mode "xpm-mode")
  53. ;;
  54. ;; I am a lisp newbie, practically everything in here I had to look up
  55. ;; in the manual.  It probably shows, suggestions for coding
  56. ;; improvements are welcomed.
  57. ;;
  58. ;; May fail on some xpm's.  Seems to be fine with files generated by
  59. ;; xpaint and ppmtoxpm anyway.  Will definitely fail on xpm's with
  60. ;; more than one character per pixel.  Not that hard to fix, but I've
  61. ;; never seen one like that.
  62. ;;
  63. ;; If your default font is proportional, this will not be very useful.
  64. ;;
  65.  
  66. (require 'annotations)
  67.  
  68. (defvar xpm-pixel-values nil)
  69. (defvar xpm-glyph nil)
  70. (defvar xpm-anno nil)
  71. (defvar xpm-paint-string nil)
  72. (defvar xpm-chars-per-pixel 1)
  73. (defvar xpm-palette nil)
  74. (defvar xpm-always-update-image nil
  75.   "If non-nil, update actual-size image after every click or drag movement.
  76. Otherwise, only update on button releases or when asked to.  This is slow.")
  77.  
  78. (make-variable-buffer-local 'xpm-palette)
  79. (make-variable-buffer-local 'xpm-chars-per-pixel)
  80. (make-variable-buffer-local 'xpm-paint-string)
  81. (make-variable-buffer-local 'xpm-glyph)
  82. (make-variable-buffer-local 'xpm-anno)
  83. (make-variable-buffer-local 'xpm-pixel-values)
  84. ;(make-variable-buffer-local 'xpm-faces-used)
  85.  
  86. (defun xpm-make-face (name)
  87.   "Makes a face with name xpm-NAME, and colour NAME."
  88.   (let ((face (make-face (intern (concat "xpm-" name))
  89.              "Temporary xpm-mode face" t)))
  90.     (set-face-background face name)
  91.     (set-face-foreground face "black")
  92.     face))
  93.  
  94. (defun xpm-init ()
  95.   "Treat the current buffer as an xpm file and colorize it."
  96.   (interactive)
  97.   (require 'picture)
  98.  
  99.   (setq xpm-pixel-values nil)
  100.   (xpm-clear-extents)
  101.   (setq xpm-palette nil)
  102.  
  103.   (message "Finding number of colors...")
  104.   (save-excursion
  105.     (goto-char (point-min))
  106.     (beginning-of-line)
  107.     (next-line 1)
  108.     (while (not (looking-at "\\s-*\""))
  109.       (next-line 1))
  110.     (next-line 1)
  111.     (while (not (looking-at "\\s-*\""))
  112.       (next-line 1))
  113.  
  114.     (save-excursion
  115.       (goto-char (point-min))
  116.       (if (re-search-forward 
  117.        "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
  118.        (point-max) t)
  119.       (setq xpm-chars-per-pixel (string-to-int (match-string 4)))))
  120.  
  121.     (let ((co 0))
  122.       (while (< co (xpm-num-colors))
  123.     (progn
  124.       (xpm-parse-color)
  125.       (setq co (1+ co))
  126.       (next-line 1)
  127.       (beginning-of-line)))))
  128.   (if (not (eq major-mode 'picture-mode))
  129.       (picture-mode))
  130.   (if (featurep 'toolbar)
  131.       (progn
  132.     (set-specifier left-toolbar-width (cons (selected-frame) 16))
  133.     (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
  134.   (message "Parsing body...")
  135.   (xpm-color-data)
  136.   (message "Parsing body...done")
  137.   (xpm-show-image))
  138.  
  139. (defun xpm-clear-extents ()
  140.   (let (cur-extent
  141.     next-extent)
  142.     (setq cur-extent (next-extent (current-buffer)))
  143.     (setq next-extent (next-extent cur-extent))
  144.     (while cur-extent
  145.       (delete-extent cur-extent)
  146.       (setq cur-extent next-extent)
  147.       (setq next-extent (next-extent cur-extent)))))
  148.  
  149. (defun xpm-color-data ()
  150.   (interactive)
  151.   (save-excursion
  152.     (xpm-goto-body-line 0)
  153.     (let (ext
  154.       pixel-chars
  155.       pixel-color)
  156.       (while (and (< (point) (point-max))
  157.           (< (+ (point) xpm-chars-per-pixel) (point-max)))
  158.     (setq pixel-chars
  159.           (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
  160.           pixel-color (assoc pixel-chars xpm-pixel-values)
  161.           ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
  162.     (if pixel-color
  163.         (progn
  164.           (set-extent-face ext (cdr pixel-color)))
  165.       (set-extent-face ext 'default))
  166.     (forward-char xpm-chars-per-pixel)))))
  167.  
  168. (defun xpm-num-colors ()
  169.   (save-excursion
  170.     (goto-char (point-min))
  171.     (if (re-search-forward 
  172.      "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
  173.      (point-max) t)
  174.     (string-to-int (match-string 3))
  175.       (error "Unable to parse xpm information"))))
  176.  
  177. (defun xpm-make-solid-pixmap (colour width height)
  178.   (let ((x 0)
  179.     (y 0)
  180.     (line nil)
  181.     (total nil))
  182.     (setq line ",\n\"")
  183.     (while (< x width)
  184.       (setq line (concat line ".")
  185.         x (+ x 1)))
  186.     (setq line (concat line "\"")
  187.       total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\""
  188.             colour width height colour))
  189.     (while (< y height)
  190.       (setq total (concat total line)
  191.         y (+ y 1)))
  192.     (make-glyph (concat total "};\n"))))
  193.  
  194. (defun xpm-store-color (str color)
  195.   "Add STR to xpm-pixel-values with a new face set to background COLOR
  196. if STR already has an entry, the existing face will be used, with the
  197. new color replacing the old (on the display only, not in the xpm color
  198. defs!)"
  199.   (let (new-face)
  200.     (setq new-face (xpm-make-face color))
  201.     (set-face-background new-face color)
  202.     (let ((ccc (color-rgb-components (make-color-specifier color))))
  203.       (if (> (length ccc) 0)
  204.       (if (or (or (> (elt ccc 0) 32767)
  205.               (> (elt ccc 1) 32767))
  206.           (> (elt ccc 2) 32767))
  207.           (set-face-foreground new-face "black")
  208.         (set-face-foreground new-face "white"))))
  209.     (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values))
  210.     (if (featurep 'toolbar)
  211.     (setq xpm-palette
  212.           (cons (vector 
  213.              (list (xpm-make-solid-pixmap color 12 12))
  214.              ;; Major cool things with quotes.....
  215.              (` 
  216.               (lambda (event)
  217.             (interactive "e")
  218.             (xpm-toolbar-select-colour event (, str))))
  219.              t
  220.              color) xpm-palette)))
  221.     ))
  222.  
  223. (defun xpm-parse-color ()
  224.   "Parse xpm color string from current line and set the color"
  225.   (interactive)
  226.   (let (end)
  227.     (save-excursion
  228.       (end-of-line)
  229.       (setq end (point))
  230.       (beginning-of-line)
  231.       (if (re-search-forward
  232.        ;; Generate a regexp on the fly
  233.        (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
  234.            "\\s-+\\([c]\\)"    ; there are more classes than 'c'
  235.            "\\s-+\\([^\"]+\\)\"")
  236.        end t)
  237.       (progn 
  238.         (xpm-store-color (match-string 1) (match-string 3))
  239.         (list (match-string 1) (match-string 3)))
  240.     (error "Unable to parse color")))))
  241.  
  242. (defun xpm-add-color (str color)
  243.   "add a color to an xpm's list of color defs"
  244.   (interactive "sPixel character: 
  245. sPixel color (any valid X color string):")
  246.   (save-excursion
  247.     (goto-char (point-min))
  248.     (while (not (looking-at "\\s-*\""))
  249.       (next-line 1))
  250.     (next-line 1)
  251.     (while (not (looking-at "\\s-*\""))
  252.       (next-line 1))
  253.     (let ((co 0))
  254.       (while (< co (xpm-num-colors))
  255.     (next-line 1)
  256.     (setq co (1+ co))))
  257.     (insert (format "\"%s\tc %s\",\n" str color))
  258.     (previous-line 1)
  259.     (xpm-parse-color)
  260.  
  261.     (goto-char (point-min))
  262.     (while (not (looking-at "\\s-*\""))
  263.       (next-line 1))
  264.     (let ((entry 0))
  265.       (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\"))
  266.     (forward-char 1))
  267.       (while (< entry 2)
  268.     (progn
  269.       (if (eq (char-after (point)) ? )
  270.           (progn
  271.         (setq entry (1+ entry))
  272.         (while (eq (char-after (point)) ? )
  273.           (forward-char 1)))
  274.         (forward-char 1))))
  275.       (let ((old-colors (xpm-num-colors)))
  276.     (while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9))
  277.       (delete-char 1))
  278.       (insert (int-to-string (1+ old-colors)))))))
  279.  
  280.  
  281. (defun xpm-goto-color-def (def)
  282.   "move to color DEF in the xpm header"
  283.   (interactive "nColor number:")
  284.   (goto-char (point-min))
  285.   (while (not (looking-at "\\s-*\""))
  286.     (next-line 1))
  287.   (next-line 1)
  288.   (while (not (looking-at "\\s-*\""))
  289.     (next-line 1))
  290.   (next-line def))
  291.  
  292. (defun xpm-goto-body-line (line)
  293.   "move to LINE lines down from the start of the body of an xpm"
  294.   (interactive "nBody line:")
  295.   (goto-char (point-min))
  296.   (xpm-goto-color-def (xpm-num-colors))
  297.   (next-line line))
  298.  
  299. (defun xpm-show-image ()
  300.   "Display the xpm in the current buffer at the end of the topmost line"
  301.   (interactive)
  302.   (save-excursion
  303.     (if (annotationp xpm-anno)
  304.     (delete-annotation xpm-anno))
  305.     (setq xpm-glyph (make-glyph 
  306.              (vector 'xpm :data 
  307.                  (buffer-substring (point-min) (point-max)))))
  308.     (goto-char (point-min))
  309.     (end-of-line)
  310.     (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))
  311.  
  312. (defun xpm-hide-image ()
  313.   "Remove the image of the xpm from the buffer"
  314.   (interactive)
  315.   (if (annotationp xpm-anno)
  316.       (delete-annotation xpm-anno)))
  317.  
  318. (defun xpm-in-body ()
  319.   (let ((p (point)))
  320.     (save-excursion
  321.       (xpm-goto-body-line 0)
  322.       (> p (point)))))
  323.  
  324. (defvar xpm-mode nil)
  325. (make-variable-buffer-local 'xpm-mode)
  326. (add-minor-mode 'xpm-mode " XPM" nil)
  327. (defvar xpm-mode-map (make-keymap))
  328.  
  329. (defun xpm-toolbar-select-colour (event chars)
  330.   "Toolbar button"
  331.   (let* ((button (event-toolbar-button event))
  332.      (help (toolbar-button-help-string button)))
  333.     (message "Toolbar selected %s (%s)"  help chars)
  334.     (setq xpm-palette
  335.       (mapcar #'(lambda (but)
  336.               (aset but 2 (not (eq help (aref but 3))))
  337.               but)
  338.           xpm-palette)
  339.       xpm-paint-string chars)
  340.     (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
  341.  
  342. (defun xpm-mouse-paint (event)
  343.   (interactive "e")
  344.   (mouse-set-point event)
  345.   (if (xpm-in-body)
  346.       ;; in body, overwrite the paint string where the mouse is clicked
  347.       (progn
  348.     (insert xpm-paint-string)
  349.     (delete-char (length xpm-paint-string)))
  350.     ;; otherwise, select the color defined by the line where the mouse
  351.     ;; was clicked
  352.     (save-excursion
  353.       (beginning-of-line)
  354.       (forward-char 1)
  355.       (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
  356.  
  357. (defun xpm-mouse-down (event n)
  358. ;  (interactive "ep")
  359.   (mouse-set-point event)
  360.   (if (xpm-in-body)
  361.       ;; in body, overwrite the paint string where the mouse is clicked
  362.       (progn
  363.     (insert xpm-paint-string)
  364.     (delete-char (length xpm-paint-string))
  365.     (if xpm-always-update-image
  366.         (xpm-show-image))
  367.     (let ((ext (make-extent (1- (point))
  368.                 (+ (1- (point)) xpm-chars-per-pixel)))
  369.           (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
  370.       (if pixel-color
  371.           (set-extent-face ext (cdr pixel-color))
  372.         (set-extent-face ext 'default))))
  373.     ;; otherwise, select the color defined by the line where the mouse
  374.     ;; was clicked
  375.     (save-excursion
  376.       (beginning-of-line)
  377.       (forward-char 1)
  378.       (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
  379.  
  380. (defun xpm-mouse-drag (event n timeout)
  381.   (or timeout
  382.       (progn
  383.     (mouse-set-point event)
  384.     (if (xpm-in-body)
  385.         ;; Much improved by not using font-lock-mode
  386.         (or (string= xpm-paint-string
  387.              (buffer-substring (point)
  388.                        (+ (length xpm-paint-string)
  389.                           (point))))
  390.         (progn
  391.           (insert-char (string-to-char xpm-paint-string) 1)
  392.                     ;      (insert xpm-paint-string)
  393.           (delete-char (length xpm-paint-string))
  394.           (if xpm-always-update-image
  395.               (xpm-show-image))
  396.           (let ((ext (make-extent
  397.                   (1- (point))
  398.                   (+ (1- (point)) xpm-chars-per-pixel)))
  399.             (pixel-color
  400.              (assoc xpm-paint-string xpm-pixel-values)))
  401.             (if pixel-color
  402.             (set-extent-face ext (cdr pixel-color))
  403.               (set-extent-face ext 'default)))))))))
  404.  
  405. (defun xpm-mouse-up (event n)
  406.   (xpm-show-image))
  407.  
  408. ;;;###autoload
  409. (defun xpm-mode (&optional arg)
  410.   "Treat the current buffer as an xpm file and colorize it.
  411.  
  412.   Shift-button-1 lets you paint by dragging the mouse.  Shift-button-1 on a
  413. color definition line will change the current painting color to that line's
  414. value.
  415.  
  416.   Characters inserted from the keyboard will NOT be colored properly yet.
  417. Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.
  418.  
  419. \\[xpm-add-color] Add a new color, prompting for character and value
  420. \\[xpm-show-image] show the current image at the top of the buffer
  421. \\[xpm-parse-color] parse the current line's color definition and add
  422.    it to the color table.  Provided as a means of changing colors.
  423. XPM minor mode bindings:
  424. \\{xpm-mode-map}"
  425.  
  426.   (interactive "P")
  427.   (setq xpm-mode
  428.     (if (null arg) (not xpm-mode)
  429.       (> (prefix-numeric-value arg) 0)))
  430.   (if xpm-mode
  431.       (progn
  432.     (xpm-init)
  433.     (make-local-variable 'mouse-track-down-hook)
  434.     (make-local-variable 'mouse-track-drag-hook)
  435.     (make-local-variable 'mouse-track-up-hook)
  436.     (make-local-variable 'mouse-track-drag-up-hook)
  437.     (make-local-variable 'mouse-track-click-hook)
  438.     (setq mouse-track-down-hook 'xpm-mouse-down)
  439.     (setq mouse-track-drag-hook 'xpm-mouse-drag)
  440.     (setq mouse-track-up-hook 'xpm-mouse-up)
  441.     (setq mouse-track-drag-up-hook 'xpm-mouse-up)
  442.     (setq mouse-track-click-hook nil)
  443.     (or (assq 'xpm-mode minor-mode-map-alist)
  444.         (progn
  445.           (define-key xpm-mode-map [(control c) r] 'xpm-show-image)
  446.           (define-key xpm-mode-map [(shift button1)] 'mouse-track)
  447.           (define-key xpm-mode-map [button1] 'mouse-track-default)
  448.           (define-key xpm-mode-map [(control c) c] 'xpm-add-color)
  449.           (define-key xpm-mode-map [(control c) p] 'xpm-parse-color)
  450.           (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map)
  451.                            minor-mode-map-alist)))))))
  452.  
  453. (provide 'xpm-mode)
  454. ;;; xpm-mode.el ends here
  455.